home *** CD-ROM | disk | FTP | other *** search
/ The Business Master (3rd Edition) / The Business Master (3rd Edition).iso / files / spreotus / 123fin / perpcal.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1980-01-01  |  5.4 KB  |  92 lines
  1. 100  ' THE PERPETUAL CALENDAR  Copyright (c) 1983 Morris Effron
  2. 140  OPTION BASE 1:DEFINT A-Z:DEFSNG T:KEY OFF:CLS:GOSUB 1000
  3. 160  LOCATE 1,37,0:PRINT "T H E":GOSUB 9000:LOCATE 3,23:PRINT "P E R P E T U A L":GOSUB 9000:LOCATE 3,43:PRINT "C A L E N D A R":GOSUB 9000
  4. 220  COLOR 0,7:LOCATE 1,37:PRINT "T H E":LOCATE 3,23:PRINT "P E R P E T U A L   C A L E N D A R":GOSUB 9000
  5. 240  COLOR 7,0:LOCATE 7,23:PRINT "1. NUMBER OF DAYS BETWEEN TWO DATES."
  6. 250  LOCATE  9,23:PRINT "2. WEEKDAY OF ANY DATE."
  7. 260  LOCATE 11,23:PRINT "3. CALENDAR FOR ANY MONTH."
  8. 270  LOCATE 13,23:PRINT "4. EXIT"
  9. 280  LOCATE 15,28:PRINT "ENTER CHOICE:":LOCATE 15,43,1:PRINT " ":LOCATE 15,43,1
  10. 300  A$=INKEY$:IF A$="" GOTO 300
  11. 310  IF A$="1" OR A$="2" OR A$="3" OR A$="4" THEN LOCATE 15,43,0:PRINT A$:ON VAL(A$) GOSUB 2000,3000,4000,5000:GOTO 280 ELSE LOCATE 16,35,0:PRINT "1, 2, 3 OR 4 PLEASE.":FOR I=1 TO 1000:NEXT I:LOCATE 16,35:PRINT SPACE$(20):GOTO 280 
  12. 1000  '  initialization routine
  13. 1005  DIM DS$(7),MS$(12),DS(12),NLP(7)
  14. 1010  DATA "SUNDAY","MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","JANUARY",31,"FEBRUARY",28,"MARCH",31,"APRIL",30,"MAY",31,"JUNE",30,"JULY",31,"AUGUST",31,"SEPTEMBER",30,"OCTOBER",31,"NOVEMBER",30,"DECEMBER",31
  15. 1020  DATA 1900,2100,2200,2300,2500,2600,2700
  16. 1030  FOR I=1 TO 7:READ DS$(I):NEXT:FOR I=1 TO 12:READ MS$(I):READ DS(I):NEXT:FOR I=1 TO 7:READ NLP(I):NEXT:RETURN
  17. 2000  '  # days between two dates
  18. 2010  LOCATE 18,23:AD$="":INPUT "FIRST DATE (MM/DD/YYYY): ",AD$:IF AD$="" THEN LOCATE 18,23:PRINT SPACE$(30):RETURN ELSE GOSUB 9100
  19. 2020  IF OKD THEN 2040
  20. 2030  LOCATE 19,30:PRINT "BAD DATE. PLEASE REENTER.":FOR I=1 TO 1000:NEXT I:LOCATE 19,30:PRINT SPACE$(25):LOCATE 18,48:PRINT SPACE$(20):GOTO 2010
  21. 2040  Y1=Y:M1=M:D1=D
  22. 2050  LOCATE 20,22:AD$="":INPUT "SECOND DATE (MM/DD/YYYY): ",AD$:GOSUB 9100
  23. 2060  IF OKD THEN 2080
  24. 2070  LOCATE 21,30:PRINT "BAD DATE. PLEASE REENTER.":FOR I=1 TO 1000:NEXT I:LOCATE 21,30:PRINT SPACE$(25):LOCATE 20,48:PRINT SPACE$(20):GOTO 2050
  25. 2080  Y2=Y:M2=M:D2=D:GOSUB 9200
  26. 2100  LOCATE 22,9:PRINT "NUMBER OF DAYS BETWEEN THESE DATES IS: ":COLOR 15,0:LOCATE 22,47:PRINT USING "###,###";TDS:COLOR 7,0:LOCATE 23,15:PRINT "(PRESS ANY KEY TO CONTINUE)"
  27. 2120  A$=INKEY$:IF A$="" GOTO 2120
  28. 2130  LOCATE 18,20:PRINT SPACE$(55):LOCATE 20,20:PRINT SPACE$(55):LOCATE 22,9:PRINT SPACE$(50):LOCATE 23,15:PRINT SPACE$(30):GOTO 2010
  29. 3000  '  weekday determination routine
  30. 3010  Y1=1983:M1=1:D1=1
  31. 3020  LOCATE 18,26:AD$="":INPUT "DATE (MM/DD/YYYY): ",AD$:IF AD$="" THEN LOCATE 18,26:PRINT SPACE$(30):RETURN ELSE GOSUB 9100
  32. 3030  IF OKD THEN 3050
  33. 3040  LOCATE 19,32:PRINT "BAD DATE. PLEASE REENTER.":FOR I=1 TO 1000:NEXT I:LOCATE 19,32:PRINT SPACE$(25):LOCATE 18,45:PRINT SPACE$(15):GOTO 3020
  34. 3050  Y2=Y:M2=M:D2=D:GOSUB 9200:WHILE TDS>32767:TDS=TDS-32767:WEND:WD=TDS MOD 7:IF PRE THEN IF WD>0 THEN WD$=DS$(WD) ELSE WD$=DS$(7) ELSE WD$=DS$(7-WD)
  35. 3070  LOCATE 20,29:PRINT "THIS DATE IS A":COLOR 15,0:LOCATE 20,44:PRINT WD$:COLOR 7,0:LOCATE 22,26:PRINT "(PRESS ANY KEY TO CONTINUE)"
  36. 3080  A$=INKEY$:IF A$="" GOTO 3080
  37. 3090  LOCATE 18,26:PRINT SPACE$(45):LOCATE 20,29:PRINT SPACE$(30):LOCATE 22,26:PRINT SPACE$(30):GOTO 3020
  38. 4000  ' calendar print routine
  39. 4010  Y1=1983:M1=1:D1=1:DIM CAL$(5,7)
  40. 4020  LOCATE 18,29:AD$="":INPUT "DATE (MM/YYYY): ",AD$:IF AD$="" THEN LOCATE 18,29:PRINT SPACE$(30):ERASE CAL$:RETURN
  41. 4030  V1=INSTR(1,AD$,"/"):IF V1=0 THEN 4050 ELSE AD$=LEFT$(AD$,V1)+"1"+MID$(AD$,V1):GOSUB 9100
  42. 4040  IF OKD THEN 4060
  43. 4050  LOCATE 19,32:PRINT "BAD DATE. PLEASE REENTER.":FOR I=1 TO 1000:NEXT I:LOCATE 19,32:PRINT SPACE$(25):LOCATE 18,45:PRINT SPACE$(15):GOTO 4020
  44. 4060  Y2=Y:M2=M:D2=D:GOSUB 9200:WHILE TDS>32767:TDS=TDS-32767:WEND:WD=TDS MOD 7:IF NOT PRE THEN WD=7-WD ELSE IF WD=0 THEN WD=7
  45. 4070  LOCATE 20,29:PRINT "PRESS ANY KEY TO PRINT"
  46. 4090  A$=INKEY$:IF A$="" GOTO 4090
  47. 4091  IF M2=2 AND LP2 THEN MX=29 ELSE MX=DS(M2)
  48. 4092  DUM=0:FOR I=1 TO 5:FOR J=1 TO 7
  49. 4094  IF ((I-1)*7)+J<WD OR DUM+1>MX THEN CAL$(I,J)=CHR$(179)+"          " ELSE DUM=DUM+1:CAL$(I,J)=CHR$(179)+STR$(DUM)+SPACE$(10-LEN(STR$(DUM)))
  50. 4095  NEXT J:NEXT I
  51. 4096  ST=0:FOR I=DUM+1 TO MX:ST=ST+1:CAL$(5,ST)=LEFT$(CAL$(5,ST),4)+"/"+MID$(STR$(I),2)+SPACE$(4)::NEXT
  52. 4100  LPRINT:LPRINT CHR$(14);:LPRINT SPACE$(17-LEN(MS$(M2))/2)+MS$(M2)+STR$(Y2):LPRINT:LPRINT " "+CHR$(218);:FOR I=1 TO 6:LPRINT STRING$(10,196)+CHR$(194);:NEXT:LPRINT STRING$(10,196)+CHR$(191):GOSUB 9510
  53. 4160  LPRINT " ";:FOR I=1 TO 7:LPRINT CHR$(179)+SPACE$((10-LEN(DS$(I)))/2)+DS$(I)+SPACE$(10-LEN(DS$(I))-(10-LEN(DS$(I)))/2-0.5);:NEXT:LPRINT CHR$(179):GOSUB 9510:GOSUB 9520
  54. 4189  FOR I=1 TO 5:LPRINT " ";:FOR J=1 TO 7:LPRINT CAL$(I,J);:NEXT J:LPRINT CHR$(179):FOR J=1 TO 5:GOSUB 9510:NEXT J:IF I<5 THEN GOSUB 9520:NEXT I
  55. 4200  LPRINT " "+CHR$(192);:FOR I=1 TO 6:LPRINT STRING$(10,196)+CHR$(193);:NEXT:LPRINT STRING$(10,196)+CHR$(217)
  56. 4205  LOCATE 22,27:PRINT "(PRESS ANY KEY TO CONTINUE)"
  57. 4206  A$=INKEY$:IF A$="" GOTO 4206
  58. 4210  LOCATE 18,20:PRINT SPACE$(50):LOCATE 20,20:PRINT SPACE$(50):LOCATE 22,27:PRINT SPACE$(30):GOTO 4020
  59. 5000  RUN"MENU.BAT
  60. 5010  KEY 1,"LIST ":KEY 2,"RUN"+CHR$(13):KEY 3,"LOAD"+CHR$(34):KEY 4,"SAVE"+CHR$(34):KEY 5,"CONT"+CHR$(13):KEY 6,","+CHR$(34)+"LPT1:"+CHR$(34)+CHR$(13):KEY 7,"TRON"+CHR$(13):KEY 8,"TROFF"+CHR$(13):KEY 9,"KEY "
  61. 5020  KEY 10,"SCREEN "+CHR$(0)+","+CHR$(0)+","+CHR$(0)+CHR$(13):CLS:KEY ON:END
  62. 9000  '  twilight zone music
  63. 9010  SOUND 600,4.5:SOUND 640,4.5:SOUND 600,4.5:SOUND 500,4.5:RETURN
  64. 9100  '  date validation
  65. 9110  OKD=0
  66. 9120  V1=INSTR(1,AD$,"/"):IF V1<1 OR V1>3 THEN RETURN
  67. 9130  V2=INSTR(V1+1,AD$,"/"):IF V2-V1<1 OR V2-V1>3 THEN RETURN
  68. 9140  IF VAL(MID$(AD$,V2+1))<1800 OR VAL(MID$(AD$,V2+1))>2800 THEN RETURN ELSE Y=VAL(MID$(AD$,V2+1))
  69. 9150  IF Y/100<>INT(Y/100) THEN IF Y/4=INT(Y/4) THEN LP=-1 ELSE LP=0 ELSE IF Y=2000 OR Y=2400 OR Y=2800 THEN LP=-1 ELSE LP=0
  70. 9160  IF VAL(MID$(AD$,1,V1-1))<1 OR VAL(MID$(AD$,1,V1-1))>12 THEN RETURN ELSE M=VAL(MID$(AD$,1,V1-1))
  71. 9170  IF M=2 AND LP THEN MX=29 ELSE MX=DS(M)
  72. 9180  IF VAL(MID$(AD$,V1+1,V2-V1-1))<1 OR VAL(MID$(AD$,V1+1,V2-V1-1))>MX THEN RETURN ELSE D=VAL(MID$(AD$,V1+1,V2-V1-1))
  73. 9190  OKD=-1:RETURN
  74. 9200  '  compute # days between date1 and date2
  75. 9210  PRE=0:TDS=0
  76. 9220  IF Y1<Y2 THEN PRE=-1
  77. 9230  IF Y1=Y2 AND M1<M2 THEN PRE=-1
  78. 9240  IF Y1=Y2 AND M1=M2 AND D1<D2 THEN PRE=-1
  79. 9242  IF Y1/100<>INT(Y1/100) THEN IF Y1/4=INT(Y1/4) THEN LP1=-1 ELSE LP1=0 ELSE IF Y1=2000 OR Y1=2400 OR Y1=2800 THEN LP1=-1 ELSE LP1=0
  80. 9243  IF Y2/100<>INT(Y2/100) THEN IF Y2/4=INT(Y2/4) THEN LP2=-1 ELSE LP2=0 ELSE IF Y2=2000 OR Y2=2400 OR Y2=2800 THEN LP2=-1 ELSE LP2=0
  81. 9245  IF PRE THEN FY=Y1:FM=M1:FD=D1:FLP=LP1:LY=Y2:LM=M2:LD=D2:LLP=LP2 ELSE FY=Y2:FM=M2:FD=D2:FLP=LP2:LY=Y1:LM=M1:LD=D1:LLP=LP1
  82. 9260  NY=LY-FY:IF NY>0 THEN TDS=INT(NY*365.25)-365
  83. 9270  FOR I=1 TO 7:IF NLP(I)>FY AND NLP(I)<LY THEN TDS=TDS-1
  84. 9280  NEXT I
  85. 9290  FOR I=1 TO LM-1:TDS=TDS+DS(I):NEXT:IF LLP AND LM>2 THEN TDS=TDS+1
  86. 9300  TDS=TDS+LD:FOR I=FM+1 TO 12:TDS=TDS+DS(I):NEXT:TDS=TDS+DS(FM)-FD:IF FLP AND FM<3 THEN TDS=TDS+1
  87. 9330  IF FY=LY THEN IF LLP THEN TDS=TDS-366 ELSE TDS=TDS-365
  88. 9340  RETURN
  89. 9500  '  calendar print subroutines
  90. 9510  LPRINT " ";:FOR K=1 TO 7:LPRINT CHR$(179)+SPACE$(10);:NEXT:LPRINT CHR$(179):RETURN
  91. 9520  LPRINT " "+CHR$(195);:FOR K=1 TO 6:LPRINT STRING$(10,196)+CHR$(197);:NEXT:LPRINT STRING$(10,196)+CHR$(180):RETURN
  92.